{-# LANGUAGE ViewPatterns, DeriveDataTypeable #-}
----------------------------------------------------------------
--                                                            --
-- Module      :  LLVM.Code.Types                             --
-- License     :  GPL3                                        --
-- Mantainer   :  Mikhail Belyaev                             --
--                                                            --
----------------------------------------------------------------

module LLVM.Code.Types where

import Data.Generics(Typeable, Data)

import LLVM.Parser.Record.Record (recordAsList)
import LLVM.Parser.Record.Record
       (getBlockId, recordAsHeadlessList, extrudeCustomRecords,
        RawBlockElem(..), RawBlock(..), BlockHeader(..), BlockType,
        RecordType, fromRawRecord, fromRawBlock)
import Data.Maybe (catMaybes)

import LLVM.Code.Shared(TypeIndex(..))
import Data.List
       (genericLength, elemIndex, findIndex, genericIndex)
import Control.Monad (liftM)

newtype TypeTable = TypeTable{types :: [Type]} deriving (Show, Eq, Typeable, Data)

data Type =
    LLVoid                                     | -- void
    LLFloat                                    | -- float
    LLDouble                                   | -- double
    LLLabel                                    | -- label
    LLOpaque                                   | -- opaque
    LLInt Integer                              | -- int <bitwidth>
    LLPointer TypeIndex Integer                | -- pointer <type> in addrspace <num>
    LLFunctionType TypeIndex [TypeIndex] Bool  | -- <vararg> func <res> -> <inps>
    LLStruct [TypeIndex] Bool                  | -- struct with <types>
    LLArray Integer TypeIndex                  | -- array of <size> and <type>
    LLVector Integer TypeIndex                 | -- array of <size> and <type>
    LLFloat80                                  | -- float80
    LLFloat128                                 | -- float 128
    LLMMX                                      | -- x86 MMX value
    LLMetadataType                               -- metadata(?)
    deriving (Show,Eq, Typeable, Data) 



instance RecordType Type where
    fromRawRecord rr = let typed = TypeIndex
                           typeds = map TypeIndex
                           bool = (/= 0)
                           oneOf vals x = x `elem` vals
                       in
                       case (recordAsHeadlessList rr) of
                            (2:_)                 -> Just LLVoid
                            (3:_)                 -> Just LLFloat
                            (4:_)                 -> Just LLDouble
                            (5:_)                 -> Just LLLabel
                            (6:_)                 -> Just LLOpaque
                            (7:v:_)               -> Just (LLInt v)
                            (8:(typed -> p):sp:_) -> Just (LLPointer p sp)
                            (9:(bool -> varg):_:(typed -> ret):(typeds -> pars))
                                                  -> Just (LLFunctionType ret pars varg)
                            ((oneOf[10,18,20] -> True):(bool -> packed):(typeds -> fls))
                                                  -> Just (LLStruct fls packed)
                            (11:sz:(typed -> els):_)
                                                  -> Just (LLArray sz els)
                            (12:sz:(typed -> els):_)
                                                  -> Just (LLVector sz els)
                            (13:_)                -> Just LLFloat80
                            (14:_)                -> Just LLFloat128
                            (15:_)                -> Just LLFloat128
                            (16:_)                -> Just LLMetadataType
                            (17:_)                -> Just LLMMX
                            -- TODO: add codes 17-20
                            _                     -> Nothing

instance BlockType TypeTable where
    fromRawBlock rb@(getBlockId -> 10) = Just (TypeTable $ extrudeCustomRecords rb)
    fromRawBlock rb@(getBlockId -> 17) = Just (TypeTable $ extrudeCustomRecords rb)
    fromRawBlock _ = Nothing

getTypeByIndex  :: TypeTable -> TypeIndex -> Maybe Type
getTypeByIndex TypeTable{types = tps} TypeIndex{tiToInteger = ix} =
    if (ix < 0 || ix >= genericLength tps) then Nothing
                                         else Just $ tps `genericIndex` ix

getIndexOfType :: TypeTable -> Type -> Maybe TypeIndex
getIndexOfType TypeTable{types = tps} tp = liftM fromIntegral $ elemIndex tp tps
